home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Misc.sea / Misc / sicn-dialog-items.lisp < prev    next >
Encoding:
Text File  |  1993-02-26  |  12.1 KB  |  351 lines  |  [TEXT/CCL2]
  1. #|To: info-macl@cambridge.apple.com
  2. Subject: SICN and SICN Palette Tool Dialog-Items
  3. Date: Wed, 01 Jul 92 07:26:58 -0400
  4. From: hohmann@zug.csmil.umich.edu
  5.  
  6.  
  7. Enclosed please find the source code for SICN and SICN Palette Tool dialog
  8. items. If you find the source helpful, great. If not, please forgive me
  9. for sending a long mail message.... ;-)
  10.  
  11. Couple of notes....
  12.   1. The example shown at the bottom won't work on your machine unless
  13.      you replace the name of the resource file listed with an appropriately
  14.      named and prepared resource file.
  15.   
  16.   2. If you locate any bugs or otherwise extend/fix this code, please drop
  17.      me a line. The code is working for me so far, but I can't make any
  18.      promises.... 
  19.  
  20.   -- Luke
  21. |#
  22. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23. ;;;
  24. ;;;  PROJECT:  SPIF
  25. ;;;
  26. ;;;  MODULE :  sicn-dialog-items.Lisp
  27. ;;;
  28. ;;;  DESCRIPTION:
  29. ;;;    A modest implementation of SICN and palette tools
  30. ;;;
  31. ;;;
  32. ;;;  NOTES:
  33. ;;;    - Thanks to Andrew Shalit for starting me off with some sample code
  34. ;;;      way back in M(A)CL 1.2.2. And thanks to the current MCL team for 
  35. ;;;      letting me steal a lot of code from the ICON-DIALOG-ITEM example
  36. ;;;      file.
  37. ;;;
  38. ;;;    - Makes use of the oodles-of-utils stuff from Mike Engbar, but 
  39. ;;;      I probably am not using that pile of code as effectively as I can!
  40. ;;;
  41. ;;;  L. Hohmann
  42. ;;;
  43. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44.  
  45. (require :quickdraw)
  46. (require :traps)
  47.  
  48.  
  49. ;; sicn-dialog-item --------------------------------------------------------
  50. ;;
  51. ;; if outline? is true then outline the dialog item with a box
  52. ;;
  53. (defclass sicn-dialog-item (dialog-item)
  54.   ((id         :initarg  :id          :accessor id)
  55.    (index      :initarg  :index       :accessor index)
  56.    (bitmap     :initform nil          :accessor bitmap)
  57.    (selected?  :initform nil          :accessor selected?)
  58.    (outline?   :initarg  :outline?    :accessor outline?))
  59.   (:default-initargs
  60.     :view-size #@(18 18)
  61.     :outline? t
  62.     :id nil
  63.     :index nil
  64.     ))
  65.  
  66.  
  67.  
  68. ;; initialize-instance --------------------------------------------------------
  69. ;;
  70. (defmethod initialize-instance :after ((self sicn-dialog-item) &rest initargs)
  71.   (declare (ignore initargs))
  72.   (unless (or (id self) (index self))
  73.     (spif-error "initialize-instance::sicn-dialog-item"
  74.                 "id=~a index=~a and one is nil and neither should be!"
  75.                 (id self) (index self))))
  76.  
  77. ;; install-view-in-window --------------------------------------------------
  78. ;;
  79. (defmethod install-view-in-window ((self sicn-dialog-item) win)
  80.   (declare (ignore win))
  81.   (initialize-bitmap self)
  82.   (call-next-method))
  83.   
  84.  
  85. ;; view-draw-contents --------------------------------------------------------
  86. ;;
  87. (defmethod view-draw-contents ((self sicn-dialog-item))
  88.   (with-accessors ((bm  bitmap)
  89.                    (pos view-position))
  90.                   self
  91.     (unless bm (error "bitmap not initialized"))
  92.     (rlet ((source-rect :rect
  93.                         :topleft #@(0 0)
  94.                         :bottomright #@(16 16))
  95.            (destination-rect :rect
  96.                              :topleft (add-points pos #@(1 1))
  97.                              :bottomright (add-points pos #@(17 17)))
  98.            (outline-rect :rect
  99.                          :topleft pos
  100.                          :bottomright (add-points pos #@(18 18))))
  101.       (copy-bits bm
  102.                  (rref (wptr (view-window self)) windowRecord.portbits)
  103.                  source-rect
  104.                  destination-rect)
  105.       (when (selected? self) 
  106.         (#_InvertRect destination-rect))
  107.       (when (outline? self)
  108.         (#_FrameRect outline-rect)))))
  109.  
  110. ;; remove-view-from-window -------------------------------------------------
  111. ;;
  112. (defmethod remove-view-from-window ((self sicn-dialog-item))
  113.   (without-interrupts 
  114.    (dispose-record (bitmap self))
  115.    (setf (bitmap self) nil))
  116.   (call-next-method))
  117.  
  118. ;; set-view-size --------------------------------------------------------
  119. ;; ignore and shodow this function because we keep these dialog items
  120. ;; a constant size
  121. ;;
  122. (defmethod set-view-size ((self sicn-dialog-item) h &optional v) 
  123.   (declare (ignore h v))
  124.   (invalidate-view self))
  125.  
  126. ;; initialize-bitmap -------------------------------------------------
  127. ;;
  128. (defmethod initialize-bitmap ((self sicn-dialog-item) 
  129.                               &aux handle handle-size new-bm)
  130.   (with-accessors ((id    id)
  131.                    (index index)
  132.                    (bm    bitmap))
  133.                   self
  134.    
  135.     (setf index (* index 32))
  136.     (without-interrupts
  137.      ; this _getresource routine searched for the sicn in the resource
  138.      ; file chain.  this chain should include the soda.rsrc file, which
  139.      ; is used in plandraw.lisp
  140.      (setf handle (get-resource "SICN" id))
  141.      (unless handle (error "sicn resource ~s not found." id))
  142.      
  143.      (#_HNoPurge handle))    
  144.     
  145.     (unwind-protect
  146.       (progn
  147.         (setf handle-size (- (#_GetHandleSize handle) 32))
  148.         (unless (<= index handle-size)
  149.           (error "index ~s out of bounds for sicn with ~s entries"
  150.                  (/ index 32)
  151.                  (/ handle-size 32)))
  152.         (setf new-bm (make-bitmap 0 0 16 16))
  153.         (with-dereferenced-handles ((pointer handle))
  154.           (#_BlockMove (%inc-ptr pointer index) (%inc-ptr new-bm 14) 32))
  155.         (setf bm new-bm))
  156.       (unless bm 
  157.         (when new-bm 
  158.           (dispose-record new-bm :bitmap)))
  159.       (#_HPurge handle))))
  160.   
  161. (defmethod view-click-event-handler ((item sicn-dialog-item) where)
  162.   (declare (ignore where))
  163.   (let* ((pos (view-position item))
  164.          (inverted-p nil))                     ;true when the mouse is over the icon
  165.     (with-focused-view (view-container item)   ;Draw in the container's coordinates
  166.       (rlet ((temp-rect :rect                  ;temporarily allocate a rectangle
  167.                         :topleft pos
  168.                         :bottomright (add-points pos (view-size item))))
  169.         (without-interrupts                
  170.          (#_InvertRect temp-rect)       ;initially invert the icon.
  171.          (setq inverted-p t)
  172.          (loop                          ;loop until the button is released
  173.            (unless (mouse-down-p)
  174.              (when inverted-p           ;if button released with mouse
  175.                                         ;  over the icon, run the action
  176.                (#_invertrect temp-rect)
  177.                (setq inverted-p nil)
  178.                (dialog-item-action item) 
  179.                )
  180.              (return-from view-click-event-handler))
  181.            (if (#_PtInRect
  182.                 (view-mouse-position (view-window item))
  183.                 temp-rect)           ;is mouse over the icon's rect?
  184.              (unless inverted-p              ;yes, make sure it's inverted.
  185.                (#_invertrect temp-rect)
  186.                (setq inverted-p t))    
  187.              (when inverted-p                ;no, make sure it's not inverted.
  188.                (#_invertrect temp-rect)
  189.                (setq inverted-p nil)))))))))
  190.  
  191. (defmethod invert ((self sicn-dialog-item))
  192.   (let* ((pos (view-position self))
  193.          (mtop (point-v pos))
  194.          (mleft (point-h pos))
  195.          (mbottom (+ mtop 18))
  196.          (mright (+ mleft 18)))
  197.     ; let the dialog do all the tracking in the dialogs grafport
  198.     (with-port (wptr (view-window self))
  199.       (rlet ((temp-rect :rect 
  200.                         :top mtop :left mleft :bottom mbottom :right mright))
  201.         (without-interrupts (#_InvertRect temp-rect)))))
  202.   (setf (selected? self) (not (selected? self))))
  203.  
  204.  
  205. ;; palette tools are bigger and always have an outline
  206. ;;
  207. (defclass palette-tool (sicn-dialog-item)
  208.   ((tool-name    :initarg :tool-name    :accessor tool-name)
  209.    (use-fn       :initarg :use-fn       :accessor use-fn)
  210.    )
  211.   (:default-initargs
  212.     :use-fn       nil
  213.     :tool-name    "A Palette Tool"
  214.     :view-size    #@(24 24)))
  215.     
  216. (defmethod use-tool ((self palette-tool) item where)
  217.   (when (functionp (use-fn self))
  218.     (apply (use-fn self) self item where)))
  219.  
  220. ;;-> dialog-item-draw palette-tool --------------------------------------------------
  221. ;;
  222. ;;   DESCRIPTION : draws the palette tool, and inverts it if selected
  223. ;;
  224. (defmethod view-draw-contents ((self palette-tool))
  225.   (with-accessors ((bm   bitmap)
  226.                    (pos  view-position)
  227.                    (size outline-size)
  228.                    (sel? selected?))
  229.                   self
  230.     (unless bm (error "bitmap not initialized"))
  231.     
  232.     (rlet ((source-rect        :rect 
  233.                                :topleft 0   
  234.                                :bottomright #@(16 16))
  235.            (destination-rect   :rect
  236.                                :topleft (add-points pos #@(4 4)) 
  237.                                :bottomright (add-points pos #@(20 20)))
  238.            (outline-rect       :rect
  239.                                :topleft pos
  240.                                :bottomright (add-points pos #@(24 24)))       
  241.            (invert-rect        :rect
  242.                                :topleft (add-points pos #@(1 1))
  243.                                :bottomright (add-points pos #@(23 23)))
  244.            )
  245.       (copy-bits bm 
  246.                  (rref (wptr (view-window self)) windowRecord.portbits) 
  247.                  source-rect destination-rect)
  248.       (#_FrameRect outline-rect)
  249.       (when sel?
  250.         (#_InvertRect invert-rect)))))
  251.  
  252. ;;-> invert palette-tool ------------------------------------------------------------
  253. ;;
  254. ;;   DESCRIPTION : toggles (via inverting) the palette tool
  255. ;;
  256. (defmethod invert ((self palette-tool))
  257.   (let* ((pos (view-position self))
  258.          )
  259.     (with-port (wptr (view-window self))
  260.       (rlet ((temp-rect :rect 
  261.                         :topleft     (add-points pos #@(1 1))
  262.                         :bottomright (add-points pos #@(23 23))))
  263.         (without-interrupts 
  264.          (#_InvertRect temp-rect))))
  265.     (setf (selected? self) 
  266.           (not (selected? self)))))
  267.  
  268. ;; dialog-item-action -------------------------------------------------
  269. ;; 
  270. ;; the following standard methods are linked via generic functions to
  271. ;; the view-window that will contain a palette-tool
  272. ;;
  273. ;; these two functions work together to select a tool and return the
  274. ;; selected tool
  275. ;;
  276. (defgeneric select-tool (view tool)
  277.   )
  278.  
  279. (defgeneric selected-tool (view)
  280.   )
  281.  
  282. (defmethod dialog-item-action ((self palette-tool))
  283.   (select-tool (view-window self) self)
  284.   (call-next-method))
  285.  
  286.  
  287. #|------------------------------------------------------------------
  288. ; test code
  289.  
  290. (defclass test-sicn-dialog (dialog)
  291.   ((selected-tool :initform nil :accessor selected-tool))
  292.   (:default-initargs
  293.     :window-title "Test sicn"))
  294.  
  295. (defmethod initialize-instance :after ((self test-sicn-dialog) &rest initargs)
  296.   (declare (ignore initargs))
  297.   
  298.   (with-res-file ("ccl:SPIF;SPIF.rsrc")
  299.     (add-subviews self
  300.                   (make-instance 'palette-tool
  301.                     :view-nick-name 'arrow
  302.                     :tool-name "Arrow (Select/Resize/Move Shapes)"
  303.                     :id 128
  304.                     :index 0
  305.                     :use-fn 'test-use-tool
  306.                     :view-position #@(20 20)))
  307.  
  308.     (add-subviews self
  309.                   (make-instance 'palette-tool
  310.                     :view-nick-name 'box
  311.                     :tool-name "Arrow (Select/Resize/Move Shapes)"
  312.                     :id 128
  313.                     :index 3
  314.                     :use-fn 'test-use-tool
  315.                     :view-position #@(43 20)))
  316.  
  317.     
  318.     (add-subviews self
  319.                   (make-instance 'sicn-dialog-item
  320.                     :view-nick-name 'eraser
  321.                     :id 128
  322.                     :index 1
  323.                     :view-position #@(0 50)
  324.                     :outline? t 
  325.                     :dialog-item-action 'test-eraser-action
  326.                     ))
  327.  
  328.     ))
  329.  
  330. (defun test-use-tool (palette-tool item where)
  331.   (format "~a is using item=[~a] at location ~a~%"
  332.           palette-tool item (point-string where)))
  333.  
  334.  
  335. (defmethod select-tool ((self test-sicn-dialog) tool)
  336.   (format t "~a is selecting tool ~a~%" self tool)
  337.   (unless (eq tool (selected-tool self))
  338.     (when (selected-tool self)
  339.       (invert (selected-tool self)))
  340.     (setf (selected-tool self) tool)
  341.     (invert tool)))
  342.  
  343. (defun test-eraser-action (item)
  344.   (format t "action for ~a~%" item))
  345.  
  346. (make-instance 'test-sicn-dialog)
  347.  
  348.  
  349. |#
  350.  
  351.